home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / debug / trace.lisp < prev    next >
Lisp/Scheme  |  1991-06-12  |  16KB  |  457 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;; Trace works by substituting trace functions for the display-write/input functions.
  20. ;; The trace functions maintain a database of requests sent to the server in the
  21. ;; trace-history display property.  This is an alist of (id . byte-vector) where
  22. ;; id is the request number for writes, :reply for replies, :event for events and
  23. ;; :error for errors.  The alist is kept in reverse order (most recent first)
  24.  
  25. ;; In a multiprocessing system is it very helpful to know what process wrote or
  26. ;; read certain requests.  Thus I have modified the format of the trace-history
  27. ;; list.  It is now an alist of: ((id . more-info) . byte-vector).
  28. ;; (more-info is a list returned by the trace-more-info function).
  29. ;; Also added the ability to suspend and resume tracing without destroying the
  30. ;; trace history.  Renamed 'display-trace' to 'show-trace' to avoid confusion.
  31. ;; 7feb91 -- jdi
  32.  
  33. ;;; Created 09/14/87 by LaMott G. OREN
  34.  
  35. (in-package :xlib)
  36.  
  37. (eval-when (load eval)
  38.   (export '(trace-display
  39.         suspend-display-tracing
  40.         resume-display-tracing
  41.         untrace-display
  42.         show-trace
  43.         display-trace        ; for backwards compatibility
  44.         describe-request
  45.         describe-event
  46.         describe-reply
  47.         describe-error
  48.         describe-trace)))
  49.  
  50. (defun trace-display (display)
  51.   "Start a trace on DISPLAY.
  52.  If display is already being traced, this discards previous history.
  53.  See show-trace and describe-trace."  
  54.   (declare (type display display))
  55.   (unless (getf (display-plist display) 'write-function)
  56.     (bind-io-hooks display))
  57.   (setf (display-trace-history display) nil)
  58.   t)
  59.  
  60. (defun suspend-display-tracing (display)
  61.   "Tracing is suspended, but history is not cleared."
  62.   (if (getf (display-plist display) 'suspend-display-tracing)
  63.       (warn "Tracing is already suspend for ~s" display)
  64.     (progn
  65.       (unbind-io-hooks display)
  66.       (setf (getf (display-plist display) 'suspend-display-tracing) t))))
  67.  
  68. (defun resume-display-tracing (display)
  69.   "Used to resume tracing after suspending"
  70.   (if (getf (display-plist display) 'suspend-display-tracing)
  71.       (progn
  72.     (bind-io-hooks display)
  73.     (remf (display-plist display) 'suspend-display-tracing))
  74.     (warn "Tracing was not suspended for ~s" display)))
  75.   
  76. (defun untrace-display (display)
  77.   "Stop tracing DISPLAY."
  78.   (declare (type display display))
  79.   (if (not (getf (display-plist display) 'suspend-display-tracing))
  80.       (unbind-io-hooks display)
  81.     (remf (display-plist display) 'suspend-display-tracing))
  82.   (setf (display-trace-history display) nil))
  83.  
  84. ;; Assumes tracing is not already on.
  85. (defun bind-io-hooks (display)
  86.   (let ((write-function (display-write-function display))
  87.     (input-function (display-input-function display)))
  88.     ;; Save origional write/input functions so we can untrace
  89.     (setf (getf (display-plist display) 'write-function) write-function)
  90.     (setf (getf (display-plist display) 'input-function) input-function)
  91.     ;; Set new write/input functions that will record what's sent to the server
  92.     (setf (display-write-function display)
  93.       #'(lambda (vector display start end)
  94.       (trace-write-hook vector display start end)
  95.       (funcall write-function vector display start end)))
  96.     (setf (display-input-function display)
  97.       #'(lambda (display vector start end timeout)
  98.       (let ((result (funcall input-function
  99.                  display vector start end timeout)))
  100.         (unless result
  101.           (trace-read-hook display vector start end))
  102.         result)))))
  103.  
  104. (defun unbind-io-hooks (display)
  105.   (let ((write-function (getf (display-plist display) 'write-function))
  106.     (input-function (getf (display-plist display) 'input-function)))
  107.     (when write-function
  108.       (setf (display-write-function display) write-function))
  109.     (when input-function
  110.       (setf (display-input-function display) input-function))
  111.     (remf (display-plist display) 'write-function)
  112.     (remf (display-plist display) 'input-function)))
  113.   
  114.  
  115. (defun byte-ref16 (vector index)
  116.   #+clx-little-endian
  117.   (logior (the card16
  118.         (ash (the card8 (aref vector (index+ index 1))) 8))
  119.       (the card8
  120.         (aref vector index)))
  121.   #-clx-little-endian
  122.   (logior (the card16
  123.         (ash (the card8 (aref vector index)) 8))
  124.       (the card8
  125.         (aref vector (index+ index 1)))))
  126.  
  127. (defun byte-ref32 (a i)
  128.   (declare (type buffer-bytes a)
  129.        (type array-index i))
  130.   (declare (values card32))
  131.   (declare-buffun)
  132.   #+clx-little-endian
  133.   (the card32
  134.        (logior (the card32
  135.             (ash (the card8 (aref a (index+ i 3))) 24))
  136.            (the card29
  137.             (ash (the card8 (aref a (index+ i 2))) 16))
  138.            (the card16
  139.             (ash (the card8 (aref a (index+ i 1))) 8))
  140.            (the card8
  141.             (aref a i))))
  142.   #-clx-little-endian
  143.   (the card32
  144.        (logior (the card32
  145.             (ash (the card8 (aref a i)) 24))
  146.            (the card29
  147.             (ash (the card8 (aref a (index+ i 1))) 16))
  148.            (the card16
  149.             (ash (the card8 (aref a (index+ i 2))) 8))
  150.            (the card8
  151.             (aref a (index+ i 3))))))
  152.  
  153. (defun trace-write-hook (vector display start end)
  154.   ;; Called only by buffer-flush.  Start should always be 0
  155.   (unless (zerop start)
  156.     (format *debug-io* "write-called with non-zero start: ~d" start))
  157.   (let* ((history (display-trace-history display))
  158.      (request-number (display-request-number display))
  159.      (last-history (car history)))
  160.     ;; There may be several requests in the buffer, and the last one may be
  161.     ;; incomplete.  The first one may be the completion of a previous request.
  162.     ;; We can detect incomplete requests by comparing the expected length of
  163.     ;; the last request with the actual length.
  164.     (when (and last-history (numberp (caar last-history)))
  165.       (let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2)))
  166.          (append-length (min (- last-length (length (cdr last-history)))
  167.                  (- end start))))
  168.     (when (plusp append-length)
  169.       ;; Last history incomplete - append to last
  170.       (setf (cdr last-history)
  171.         (concatenate '(vector card8) (cdr last-history)
  172.              (subseq vector start (+ start append-length))))
  173.       (index-incf start append-length))))
  174.     ;; Copy new requests into the history
  175.     (do* ((new-history nil)
  176.       (i start (+ i length))
  177.       request
  178.       length)
  179.      ((>= i end)
  180.       ;; add in sequence numbers
  181.       (dolist (entry new-history)
  182.         (setf (caar entry) request-number)
  183.         (decf request-number))
  184.       (setf (display-trace-history display)
  185.         (nconc new-history history)))
  186.       (setq request (aref vector i))
  187.       (setq length (index* 4 (byte-ref16 vector (+ i 2))))
  188.       (when (zerop length)
  189.     (warn "Zero length in buffer")
  190.     (return nil))
  191.       (push (cons (cons 0 (trace-more-info display request vector
  192.                        i (min (+ i length) end)))
  193.           (subseq vector i (min (+ i length) end))) new-history)
  194.       (when (zerop request)
  195.     (warn "Zero length in buffer")
  196.     (return nil)))))
  197.  
  198. (defun trace-read-hook (display vector start end)
  199.   ;; Reading is done with an initial length of 32 (with start = 0)
  200.   ;; This may be followed by several other reads for long replies.
  201.   (let* ((history (display-trace-history display))
  202.      (last-history (car history))
  203.      (length (- end start)))
  204.     (when (and history (eq (caar last-history) :reply))
  205.       (let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4))))
  206.          (append-length (min (- last-length (length (cdr last-history)))
  207.                  (- end start))))
  208.     (when (plusp append-length)
  209.       (setf (cdr last-history)
  210.         (concatenate '(vector card8) (cdr last-history)
  211.              (subseq vector start (+ start append-length))))
  212.       (index-incf start append-length)
  213.       (index-decf length append-length))))
  214.     
  215.     ;; Copy new requests into the history
  216.     (when (plusp length)
  217.       (let ((reply-type (case (aref vector start) (0 :error) (1 :reply)
  218.                   (otherwise :event))))
  219.     (push (cons (cons reply-type
  220.               (trace-more-info display reply-type vector start
  221.                        (+ start length)))
  222.             (subseq vector start (+ start length)))
  223.         (display-trace-history display))))))
  224.  
  225. (defun trace-more-info (display request-id vector start end)
  226.   ;; Currently only returns current process.
  227.   #+allegro
  228.   (list mp::*current-process*))
  229.  
  230.  
  231. (defun show-trace (display &key length show-process)
  232.   "Display the trace history for DISPLAY.
  233.  The default is to show ALL history entries.
  234.  When the LENGTH parameter is used, only the last LENGTH entries are
  235.  displayed."
  236.   (declare (type display display))
  237.   (dolist (hist (reverse (subseq (display-trace-history display)
  238.                  0 length)))
  239.     (let* ((id (caar hist))
  240.        (more-info (cdar hist))
  241.        (vector (cdr hist))
  242.        (length (length vector))
  243.        (request (aref vector 0)))
  244.       (format t "~%~5d " id)
  245.       (case id
  246.     (:error
  247.      (trace-error-print display more-info vector))
  248.     (:event
  249.      (format t "~a (~d) Sequence ~d"
  250.          (if (< request (length *event-key-vector*))
  251.              (aref *event-key-vector* request)
  252.            "Unknown")
  253.          request
  254.          (byte-ref16 vector 2))
  255.      (when show-process
  256.        #+allegro
  257.        (format t ", Proc ~a" (mp::process-name (car more-info)))))
  258.     (:reply
  259.      (format t "To ~d length ~d"
  260.          (byte-ref16 vector 2) length)
  261.      (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
  262.        (unless (= length actual-length)
  263.          (format t " Should be ~d **************" actual-length)))
  264.      (when show-process
  265.        #+allegro
  266.        (format t ", Proc ~a" (mp::process-name (car more-info)))))
  267.     (otherwise
  268.      (format t "~a (~d) length ~d"
  269.          (request-name request) request length)
  270.      (when show-process
  271.        #+allegro
  272.        (format t ", Proc ~a" (mp::process-name (car more-info)))))))))
  273.  
  274. ;; For backwards compatibility
  275. (defun display-trace (&rest args)
  276.   (apply 'show-trace args))
  277.  
  278. (defun find-trace (display type sequence &optional (number 0))
  279.   (dolist (history (display-trace-history display))
  280.     (when (and (symbolp (caar history))
  281.            (= (logandc2 (aref (cdr history) 0) 128) type)
  282.            (= (byte-ref16 (cdr history) 2) sequence)
  283.            (minusp (decf number)))
  284.       (return (cdr history)))))
  285.  
  286. (defun describe-error (display sequence)
  287.   "Describe the error associated with request SEQUENCE."
  288.   (let ((vector (find-trace display 0 sequence)))
  289.     (if vector
  290.     (progn
  291.       (terpri)
  292.       (trace-error-print display nil vector))
  293.       (format t "Error with sequence ~d not found." sequence))))
  294.  
  295. (defun trace-error-print (display more-info vector
  296.               &optional (stream *standard-output*))
  297.   (let ((event (allocate-event)))
  298.     ;; Copy into event from reply buffer
  299.     (buffer-replace (reply-ibuf8 event)
  300.             vector
  301.             0
  302.             *replysize*)
  303.     (reading-event (event)
  304.       (let* ((type (read-card8 0))
  305.          (error-code (read-card8 1))
  306.          (sequence (read-card16 2))
  307.          (resource-id (read-card32 4))
  308.          (minor-code (read-card16 8))
  309.          (major-code (read-card8 10))
  310.          (current-sequence (ldb (byte 16 0) (buffer-request-number display)))
  311.          (error-key
  312.            (if (< error-code (length *xerror-vector*))
  313.            (aref *xerror-vector* error-code)
  314.          'unknown-error))
  315.          (params
  316.            (case error-key
  317.          ((colormap-error cursor-error drawable-error font-error gcontext-error
  318.                   id-choice-error pixmap-error window-error)
  319.           (list :resource-id resource-id))
  320.          (atom-error 
  321.           (list :atom-id resource-id))
  322.          (value-error
  323.           (list :value resource-id))
  324.          (unknown-error
  325.           ;; Prevent errors when handler is a sequence
  326.           (setq error-code 0)
  327.           (list :error-code error-code)))))
  328.     type
  329.     (let ((condition 
  330.         (apply #+lispm #'si:make-condition
  331.                #+allegro #'make-condition
  332.                #-(or lispm allegro) #'make-condition
  333.                error-key
  334.                :error-key error-key
  335.                :display display
  336.                :major major-code
  337.                :minor minor-code
  338.                :sequence sequence
  339.                :current-sequence current-sequence
  340.                params)))
  341.       (princ condition stream)
  342.       (deallocate-event event)
  343.       condition)))))
  344.  
  345. (defun describe-request (display sequence)
  346.   "Describe the request with sequence number SEQUENCE"
  347.   #+ti (si:load-if "clx:debug;describe")
  348.   (let ((request (assoc sequence (display-trace-history display)
  349.                :test #'(lambda (item key)
  350.                  (eql item (car key))))))
  351.     (if (null request)
  352.     (format t "~%Request number ~d not found in trace history" sequence)
  353.       (let* ((vector (cdr request))
  354.          (len (length vector))
  355.          (hist (make-reply-buffer len)))
  356.     (buffer-replace (reply-ibuf8 hist) vector 0 len)
  357.     (print-history-description hist)))))
  358.  
  359. (defun describe-reply (display sequence)
  360.   "Print the reply to request SEQUENCE.
  361.  (The current implementation doesn't print very pretty)"
  362.   (let ((vector (find-trace display 1 sequence))
  363.     (*print-array* t))
  364.     (if vector
  365.     (print vector)
  366.       (format t "~%Reply not found"))))
  367.  
  368. (defun event-number (name)
  369.   (if (integerp name)
  370.       (let ((name (logandc2 name 128)))
  371.     (if (typep name '(integer 0 63))
  372.         (aref *event-key-vector* name))
  373.     name)
  374.     (position (string name) *event-key-vector* :test #'equalp :key #'string)))
  375.  
  376. (defun describe-event (display name sequence &optional (number 0))
  377.   "Describe the event with event-name NAME and sequence number SEQUENCE.
  378. If there is more than one event, return NUMBER in the sequence."
  379.   (declare (type display display)
  380.        (type (or stringable (integer 0 63)) name)
  381.        (integer sequence))
  382.   (let* ((event (event-number name))
  383.      (vector (and event (find-trace display event sequence number))))
  384.     (if (not event)
  385.     (format t "~%~s isn't an event name" name)
  386.       (if (not vector)
  387.       (if (and (plusp number) (setq vector (find-trace display event sequence 0)))
  388.           (do ((i 1 (1+ i))
  389.            (last-vector))
  390.           (nil)
  391.         (if (setq vector (find-trace display event sequence i))
  392.             (setq last-vector vector)
  393.           (progn 
  394.             (format t "~%Event number ~d not found, last event was ~d"
  395.                 number (1- i))
  396.             (return (trace-event-print display last-vector)))))
  397.         (format t "~%Event ~s not found"
  398.             (aref *event-key-vector* event)))
  399.     (trace-event-print display vector)))))
  400.  
  401. (defun trace-event-print (display vector)
  402.   (let* ((event (allocate-event))
  403.      (event-code (ldb (byte 7 0) (aref vector 0)))
  404.      (event-decoder (aref *event-handler-vector* event-code)))
  405.     ;; Copy into event from reply buffer
  406.     (setf (event-code event) event-code)
  407.     (buffer-replace (reply-ibuf8 event)
  408.             vector
  409.             0
  410.             *replysize*)
  411.     (prog1 (funcall event-decoder display event
  412.             #'(lambda (&rest args &key send-event-p &allow-other-keys)
  413.             (setq args (copy-list args))
  414.             (remf args :display)
  415.             (remf args :event-code)
  416.             (unless send-event-p (remf args :send-event-p))
  417.             args))
  418.        (deallocate-event event))))
  419.  
  420. (defun describe-trace (display &optional length)
  421.   "Display the trace history for DISPLAY.
  422.  The default is to show ALL history entries.
  423.  When the LENGTH parameter is used, only the last LENGTH entries are
  424.  displayed."
  425.   (declare (type display display))
  426.   #+ti (si:load-if "clx:debug;describe")
  427.   (dolist (hist (reverse (subseq (display-trace-history display)
  428.                  0 length)))
  429.     (let* ((id (car hist))
  430.        (vector (cdr hist))
  431.        (length (length vector)))
  432.       (format t "~%~5d " id)
  433.       (case id
  434.     (:error
  435.      (trace-error-print display nil vector))
  436.     (:event
  437.      (let ((event (trace-event-print display vector)))
  438.        (when event (format t "from ~d ~{ ~s~}"
  439.                    (byte-ref16 vector 2) event))))
  440.     (:reply
  441.      (format t "To ~d length ~d"
  442.          (byte-ref16 vector 2) length)
  443.      (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
  444.        (unless (= length actual-length)
  445.          (format t " Should be ~d **************" actual-length)))
  446.      (let ((*print-array* t)
  447.            (*print-base* 16.))
  448.        (princ " ")
  449.        (princ vector)))
  450.     (otherwise
  451.       (let* ((len (length vector))
  452.          (hist (make-reply-buffer len)))
  453.         (buffer-replace (reply-ibuf8 hist) vector 0 len)
  454.         (print-history-description hist)))))))
  455.  
  456. ;; End of file
  457.